home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / kcl-low.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  15KB  |  416 lines
  1. ;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; The version of low for Kyoto Common Lisp (KCL)
  28. (in-package "SI")
  29. (export '(%structure-name
  30.           %compiled-function-name
  31.           %set-compiled-function-name))
  32. (in-package 'pcl)
  33. (import 'si:structurep)
  34.  
  35. (shadow 'lisp:dotimes)
  36.  
  37. (defmacro dotimes ((var form &optional (val nil)) &rest body &environment env)
  38.   (multiple-value-bind (doc decls bod)
  39.       (extract-declarations body env)
  40.     (declare (ignore doc))
  41.     (let ((limit (gensym))
  42.           (label (gensym)))
  43.       `(let ((,limit ,form)
  44.              (,var 0))
  45.          (declare (fixnum ,limit ,var))
  46.          ,@decls
  47.          (block nil
  48.            (tagbody
  49.             ,label
  50.               (when (>= ,var ,limit) (return-from nil ,val))
  51.               ,@bod
  52.               (setq ,var (the fixnum (1+ ,var)))
  53.               (go ,label)))))))
  54.  
  55. (defun memq (item list) (member item list :test #'eq))
  56. (defun assq (item list) (assoc item list :test #'eq))
  57. (defun posq (item list) (position item list :test #'eq))
  58.  
  59. (si:define-compiler-macro memq (item list) 
  60.   (let ((var (gensym)))
  61.     (once-only (item)
  62.       `(let ((,var ,list))
  63.          (loop (unless ,var (return nil))
  64.                (when (eq ,item (car ,var))
  65.                  (return ,var))
  66.                (setq ,var (cdr ,var)))))))
  67.  
  68. (si:define-compiler-macro assq (item list) 
  69.   (let ((var (gensym)))
  70.     (once-only (item)
  71.       `(dolist (,var ,list nil)
  72.          (when (eq ,item (car ,var))
  73.            (return ,var))))))
  74.  
  75. (si:define-compiler-macro posq (item list) 
  76.   (let ((var (gensym)) (index (gensym)))
  77.     (once-only (item)
  78.       `(let ((,var ,list) (,index 0))
  79.          (declare (fixnum ,index))
  80.          (dolist (,var ,list nil)
  81.            (when (eq ,item ,var)
  82.              (return ,index))
  83.            (incf ,index))))))
  84.  
  85. (defun printing-random-thing-internal (thing stream)
  86.   (format stream "~O" (si:address thing)))
  87.  
  88.  
  89. #+akcl
  90. (eval-when (load compile eval)
  91.  
  92. ;compiler::*compile-ordinaries* is set to t in kcl-patches
  93.  
  94. (if (and (boundp 'si::*akcl-version*)
  95.      (>= si::*akcl-version* 604))
  96.     (progn
  97.       (pushnew :turbo-closure *features*)
  98.       (pushnew :turbo-closure-env-size *features*))
  99.     (when (fboundp 'si::allocate-growth) 
  100.       (pushnew :turbo-closure *features*)))
  101.  
  102. ;; patch around compiler bug.
  103. (when (<= si::*akcl-version* 609)
  104.   (let ((vcs "static int Vcs;
  105. "))
  106.     (unless (search vcs compiler::*cmpinclude-string*)
  107.       (setq compiler::*cmpinclude-string*
  108.         (concatenate 'string vcs compiler::*cmpinclude-string*)))))
  109.  
  110. )
  111.  
  112. (defmacro %svref (vector index)
  113.   `(svref (the simple-vector ,vector) (the fixnum ,index)))
  114.  
  115. (defsetf %svref (vector index) (new-value)
  116.   `(setf (svref (the simple-vector ,vector) (the fixnum ,index))
  117.          ,new-value))
  118.  
  119.  
  120. ;;;
  121. ;;; std-instance-p
  122. ;;;
  123. #-akcl
  124. (si:define-compiler-macro std-instance-p (x)
  125.   (once-only (x)
  126.     `(and (si:structurep ,x)
  127.           (eq (si:%structure-name ,x) 'std-instance))))
  128.  
  129. #+akcl
  130. (progn
  131.  
  132. ;; declare that std-instance-p may be computed simply, and will not change.
  133. (si::freeze-defstruct 'std-instance)
  134.  
  135.  
  136. (defvar *pcl-funcall*  '(lambda (loc)
  137.           (compiler::wt-nl
  138.            "{object _funobj = " loc ";"
  139.            "if(type_of(_funobj)==t_cclosure && (_funobj->cc.cc_turbo))
  140.                    (*(_funobj->cc.cc_self))(_funobj->cc.cc_turbo);
  141.                else if (type_of(_funobj)==t_cfun) (*(_funobj->cc.cc_self))();
  142.                else super_funcall_no_event(_funobj);}")))
  143. (setq compiler::*super-funcall* *pcl-funcall*)
  144.  
  145. )
  146.  
  147. (defun function-ftype-declaimed-p (name)
  148.   "Returns whether the function given by name already has its ftype declaimed."
  149.   (get name 'compiler::proclaimed-function))
  150.  
  151.  
  152. ;;;
  153. ;;; turbo-closure patch.  See the file kcl-mods.text for details.
  154. ;;;
  155. #-turbo-closure-env-size
  156. (clines "
  157. object cclosure_env_nthcdr (n,cc)
  158. int n; object cc;
  159. {  object env;
  160.    if(n<0)return Cnil;
  161.    if(type_of(cc)!=t_cclosure)return Cnil;
  162.    env=cc->cc.cc_env;
  163.    while(n-->0)
  164.      {if(type_of(env)!=t_cons)return Cnil;
  165.       env=env->c.c_cdr;}
  166.    return env;
  167. }")
  168.  
  169. #+turbo-closure-env-size
  170. (clines "
  171. object cclosure_env_nthcdr (n,cc)
  172. int n; object cc;
  173. {  object env,*turbo;
  174.    if(n<0)return Cnil;
  175.    if(type_of(cc)!=t_cclosure)return Cnil;
  176.    if((turbo=cc->cc.cc_turbo)==NULL)
  177.      {env=cc->cc.cc_env;
  178.       while(n-->0)
  179.         {if(type_of(env)!=t_cons)return Cnil;
  180.          env=env->c.c_cdr;}
  181.       return env;}
  182.    else
  183.      {if(n>=fix(*(turbo-1)))return Cnil;
  184.       return turbo[n];}
  185. }")
  186.  
  187. ;; This is the completely safe version.
  188. (defentry cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))
  189. ;; This is the unsafe but fast version.
  190. (defentry %cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))
  191.  
  192. ;;; #+akcl means this is an AKCL newer than 5/11/89 (structures changed)
  193. (eval-when (compile load eval)
  194.  
  195. ;;((name args-type result-type side-effect-p new-object-p c-expression) ...)
  196. (defparameter *kcl-function-inlines*
  197.   '(#-akcl (si:structurep (t) compiler::boolean nil nil "type_of(#0)==t_structure")
  198.     #-akcl (si:%structure-name (t) t nil nil "(#0)->str.str_name")
  199.     #+akcl (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]")
  200.     (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name")
  201.     (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)")
  202.     (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure")
  203.     (%cclosure-env (t) t nil nil "(#0)->cc.cc_env")
  204.     (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)")
  205.     #+turbo-closure
  206.     (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")
  207.     
  208.     (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))")))
  209.  
  210. (defun make-function-inline (inline)
  211.   (setf (get (car inline) 'compiler::inline-always)
  212.         (list (if (fboundp 'compiler::flags)
  213.                   (let ((opt (cdr inline)))
  214.                     (list (first opt) (second opt)
  215.                           (logior (if (fourth opt) 1 0) ; allocates-new-storage
  216.                                   (if (third opt) 2 0)  ; side-effect
  217.                                   (if nil 4 0) ; constantp
  218.                                   (if (eq (car inline) 'logxor)
  219.                                       8 0)) ;result type from args
  220.                           (fifth opt)))
  221.                   (cdr inline)))))
  222.  
  223. (defmacro define-inlines ()
  224.   `(progn
  225.     ,@(mapcan #'(lambda (inline)
  226.                   (let ((name (intern (format nil "~S inline" (car inline))))
  227.                         (vars (mapcar #'(lambda (type)
  228.                                           (declare (ignore type))
  229.                                           (gensym))
  230.                                       (cadr inline))))
  231.                     `((make-function-inline ',(cons name (cdr inline)))
  232.                       ,@(when (or (every #'(lambda (type) (eq type 't))
  233.                                          (cadr inline))
  234.